home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / you-075a.lha / you-075a / extras0.em < prev    next >
Lisp/Scheme  |  1992-06-18  |  10KB  |  398 lines
  1. ;; Eulisp Module
  2. ;; Author: pab
  3. ;; File: extras0.em
  4. ;; Date: Fri Jan 10 04:17:12 1992
  5. ;;
  6. ;; Project:
  7. ;; Description: 
  8. ;;
  9.  
  10. (defmodule extras0
  11.   (ccc lists list-operators others arith calls macros0 tables
  12.        (except (null) class-names)
  13.        classes
  14.        symbols
  15.        formatted-io
  16.        generics
  17.        vectors
  18.        strings
  19.        ) ()
  20.  
  21.   (defun not (widget) (null widget))
  22.  
  23.   (export not)
  24.  
  25.   (defun caar (x) (car (car x)))
  26.   (defun cadr (x) (car (cdr x)))
  27.   (defun cdar (x) (cdr (car x)))
  28.   (defun cddr (x) (cdr (cdr x)))
  29.  
  30.   (export caar cadr cdar cddr)
  31.  
  32.   (defun caaar (x) (car (car (car x))))
  33.   (defun caadr (x) (car (car (cdr x))))
  34.   (defun cadar (x) (car (cdr (car x))))
  35.   (defun caddr (x) (car (cdr (cdr x))))
  36.   (defun cdaar (x) (cdr (car (car x))))
  37.   (defun cdadr (x) (cdr (car (cdr x))))
  38.   (defun cddar (x) (cdr (cdr (car x))))
  39.   (defun cdddr (x) (cdr (cdr (cdr x))))
  40.  
  41.   (export caaar caadr cadar caddr cdaar cdadr cddar cdddr)
  42.  
  43.   (defun caaaar (x) (car (car (car (car x)))) )
  44.   (defun caaadr (x) (car (car (car (cdr x)))) )
  45.   (defun caadar (x) (car (car (cdr (car x)))) )
  46.   (defun caaddr (x) (car (car (cdr (cdr x)))) )
  47.   (defun cadaar (x) (car (cdr (car (car x)))) )
  48.   (defun cadadr (x) (car (cdr (car (cdr x)))) )
  49.   (defun caddar (x) (car (cdr (cdr (car x)))) )
  50.   (defun cadddr (x) (car (cdr (cdr (cdr x)))) )
  51.   (defun cdaaar (x) (cdr (car (car (car x)))) )
  52.   (defun cdaadr (x) (cdr (car (car (cdr x)))) )
  53.   (defun cdadar (x) (cdr (car (cdr (car x)))) )
  54.   (defun cdaddr (x) (cdr (car (cdr (cdr x)))) )
  55.   (defun cddaar (x) (cdr (cdr (car (car x)))) )
  56.   (defun cddadr (x) (cdr (cdr (car (cdr x)))) )
  57.   (defun cdddar (x) (cdr (cdr (cdr (car x)))) )
  58.   (defun cddddr (x) (cdr (cdr (cdr (cdr x)))) )
  59.  
  60.   (export caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr 
  61.       cdaaar cdaadr cdadar cdaddr cddaar cdddar cddadr cddddr)
  62.  
  63.   (defun eqcar (a b) (cond ((atom a) nil) ((eq (car a) b) t) (t nil)))
  64.  
  65.   (export eqcar)
  66.  
  67.   (defun mkquote (x) (list 'quote x))
  68.  
  69.   (export mkquote)
  70.  
  71.   (defun assq (a l)
  72.     (cond
  73.      ((null l) nil)
  74.      ((eq a (caar l)) (car l))
  75.      (t (assq a (cdr l)))) )
  76.  
  77.   (export assq)
  78.  
  79.   (defun list-ref (l n)
  80.     (if (equal n 0) (car l)
  81.       (list-ref (cdr l) (\- n 1))))
  82.  
  83.   (export list-ref)
  84.  
  85.   (defun \@list-ref-update\@ (l n obj)
  86.     (if (equal n 0) ((setter car) l obj)
  87.       (\@list-ref-update\@ (cdr l) (- n 1) obj)))
  88.  
  89.   (defun reverse (l)
  90.     (reverse-aux l nil))
  91.  
  92.   (defun reverse-aux (l so-far)
  93.     (if l (reverse-aux (cdr l)
  94.              (cons (car l) so-far))
  95.       so-far))
  96.  
  97.   ;;  (defun reverse (l)
  98.   ;;    (labels ((rev1 (l n)
  99.   ;;           (if (null l) n
  100.   ;;             (rev1 (cdr l) (cons (car l) n)))))
  101.   ;;        (rev1 l nil)))
  102.  
  103.   (export reverse)
  104.  
  105.   (defun subst (a b c)
  106.     (cond
  107.      ((equal c b) a)
  108.      ((atom c) c)
  109.      (t 
  110.       ((lambda (carc cdrc)
  111.      (cond ((and (eq carc (car c)) (eq cdrc (cdr c))) c)
  112.            (t (cons carc cdrc))))
  113.        (subst a b (car c))
  114.        (subst a b (cdr c))))))
  115.  
  116.   (export subst)
  117.  
  118.   (defun delete (a b comp)
  119.     (cond
  120.      ((null b) nil)
  121.      ((comp a (car b)) (cdr b))
  122.      (t ((lambda (del)
  123.        (cond ((eq del (cdr b)) b)
  124.          (t (cons (car b) del))))
  125.      (delete a (cdr b) comp)))))
  126.  
  127.   (export delete)
  128.  
  129.   (defun deleteq (a b)
  130.     (cond
  131.      ((null b) nil)
  132.      ((eq a (car b)) (cdr b))
  133.      (t ((lambda (del)
  134.        (cond ((eq del (cdr b)) b)
  135.          (t (cons (car b) del))))
  136.      (deleteq a (cdr b))))))
  137.  
  138.   (export deleteq)
  139.  
  140.   ;;
  141.   ;; Missing bits...
  142.   ;;
  143.  
  144.   (defun negativep (i) (binary-lt i 0))
  145.  
  146.   (export negativep)
  147.  
  148.   (defun list-copy-aux (l new)
  149.     (if l (list-copy-aux (cdr l) (nconc new (cons (car l) nil)))
  150.       new))
  151.  
  152.   (defun list-copy (l) (list-copy-aux l nil))
  153.  
  154.   (export list-copy)
  155.  
  156.  
  157.   ;; Conversion
  158.   ;; According to the standard (nearly)
  159.  
  160.   (defconstant *convert-tab* (make-table eq))
  161.  
  162.   (defun converter (class)
  163.     (let ((xx (table-ref *convert-tab* class)))
  164.       (if (not (null xx))
  165.       xx
  166.     (let ((new-gen (make-converter-generic class)))
  167.       ((setter converter) class new-gen)
  168.       new-gen))))
  169.       
  170.   (interpret-time 
  171.    (defun make-converter-generic (class)
  172.      (let ((gf (make-instance generic-function
  173.                   'name (make-symbol (format nil "~a-converter" (class-name class)))
  174.                   'lambda-list '(a)
  175.                   'method-class method)))
  176.        (add-method gf (make-instance method 
  177.                      'signature (list class)
  178.                      'function (lambda (x y o) o))))))
  179.  
  180.   
  181.   (compile-time 
  182.    (defun make-converter-generic (class)
  183.      (let ((gf (make-instance generic-function
  184.                   'name (make-symbol (format nil "~a-converter" (class-name class)))
  185.                   'lambda-list '(a)
  186.                   'method-class method)))
  187.        (add-method gf (make-instance method 
  188.                      'signature (list class)
  189.                      'function (lambda (o) o))))))
  190.  
  191.   
  192.   
  193.   ((setter setter) converter
  194.    (lambda (class fn)
  195.      ((setter table-ref) *convert-tab* class fn)))
  196.   
  197.   
  198.   (defun convert (x class)
  199.     ((converter class) x))
  200.   
  201.   (export converter convert)
  202.   ;; shove in the defined methods...
  203.   ;; Really so trivial that we could use lisp functions...
  204.  
  205.   (add-method (converter vector)
  206.           (make-instance method
  207.                  'signature (list pair)
  208.                  'function generic_generic_convert\,Cons\,Vector))
  209.  
  210.   (add-method (converter pair)
  211.           (make-instance method 
  212.                  'signature (list vector)
  213.                  'function generic_generic_convert\,Vector\,Cons))
  214.  
  215.   (compile-time
  216.    (add-method (converter vector)
  217.            (make-instance method
  218.                  'signature (list (class-of nil))
  219.                  'function 
  220.                  (lambda (c)
  221.                    (make-vector 0))))
  222.  
  223.    (add-method (converter string)
  224.            (make-instance method 
  225.                   'signature (list object)
  226.                   'function (lambda (obj)
  227.                       (format nil "~a" obj))))
  228.    (add-method (converter string)
  229.            (make-instance method 
  230.                   'signature (list character)
  231.                   'function (lambda (obj)
  232.                       (make-string 1 obj))))
  233.    )
  234.  
  235.   (interpret-time
  236.    (add-method (converter vector)
  237.            (make-instance method
  238.                  'signature (list (class-of nil))
  239.                  'function 
  240.                  (lambda (a b c)
  241.                    (make-vector 0))))
  242.  
  243.    (add-method (converter string)
  244.            (make-instance method 
  245.                   'signature (list object)
  246.                   'function (lambda (a b obj)
  247.                       (format nil "~a" obj))))
  248.    (add-method (converter string)
  249.            (make-instance method 
  250.                   'signature (list character)
  251.                   'function (lambda (a b obj)
  252.                       (make-string 1 obj))))
  253.    )
  254.  
  255.   ;; Also need to add:
  256.   ;; (allsorts) number from string
  257.   ;; char<-->int
  258.   ;; string->pair
  259.  
  260.  
  261.   ;; Changing the habit of a lifetime
  262.  
  263.   (interpret-time 
  264.    (defconstant length (make-instance generic-function 
  265.                      'name 'length
  266.                      'lambda-list '(l)
  267.                      'method-class method))
  268.  
  269.   (add-method length (make-instance method
  270.                     'signature (list pair)
  271.                     'function list-length))
  272.  
  273.   (add-method length (make-instance method
  274.                     'signature (list (class-of nil))
  275.                     'function (lambda (a b x) 0)))
  276.  
  277.   (add-method length (make-instance method 
  278.                     'signature (list vector)
  279.                     'function vector-length))
  280.  
  281.   (add-method length (make-instance method
  282.                     'signature (list string)
  283.                     'function string-length))
  284.   )
  285.   (compile-time 
  286.    (defconstant length (make-instance generic-function 
  287.                      'name 'length
  288.                      'lambda-list '(l)
  289.                      'method-class method))
  290.  
  291.   (add-method length (make-instance method
  292.                     'signature (list pair)
  293.                     'function list-length))
  294.  
  295.   (add-method length (make-instance method
  296.                     'signature (list (class-of nil))
  297.                     'function (lambda (x) 0)))
  298.  
  299.   (add-method length (make-instance method 
  300.                     'signature (list vector)
  301.                     'function vector-length))
  302.  
  303.   (add-method length (make-instance method
  304.                     'signature (list string)
  305.                     'function string-length))
  306.   )
  307.   (export length)
  308.  
  309.  
  310. (defun mapcan (f l)
  311.   (if (atom l) nil
  312.     (nconc (f (car l))
  313.        (mapcan f (cdr l)))))
  314.  
  315.  (defconstant generic-function-methods
  316.     (make-instance generic-function
  317.            'name 'generic-function-methods
  318.            'lambda-list '(gf)
  319.            'method-class method))
  320.  
  321.   (export generic-function-methods)
  322.  
  323. ;; interpret only
  324.   (defun gfm (x y gf)
  325.     (labels ((get-method (l)
  326.            (if (atom (cadr l))
  327.            (list (cadr l))
  328.          (mapcan get-method (cdr l)))))
  329.         (mapcan get-method (generic-method-table gf))))
  330.  
  331.   (add-method generic-function-methods
  332.     (make-instance method
  333.            'signature (list generic-function)
  334.            'function gfm))
  335.  
  336.   (defconstant find-method
  337.     (make-instance generic-function
  338.            'name 'find-method
  339.            'lambda-list '(gf sig)
  340.            'method-class method))
  341.  
  342.   (defun match-sigs (sig meths)
  343.     (cond ((atom meths) ())
  344.       ((equal sig (method-signature (car meths))) (car meths))
  345.       (t (match-sigs sig (cdr meths)))))
  346.  
  347.   (add-method find-method
  348.     (make-instance method
  349.            'signature (list generic-function pair)
  350.            'function (lambda (x y gf sig)
  351.                   (match-sigs sig (generic-function-methods gf)))))
  352.  
  353.   (export find-method)
  354.  
  355. ;; next version junk....
  356.  
  357. (defun make-constructor (class)
  358.   (lambda a
  359.     (initialize-instance (allocate-instance class a) a)))
  360.  
  361. (export make-constructor)
  362.  
  363. ;; add make-predicate...
  364.  
  365. (defconstant make-predicate
  366.   (make-instance generic-function
  367.          'name 'make-predicate
  368.          'lambda-list '(class)
  369.          'method-class method))
  370.  
  371.  
  372. ;; probably portable
  373. (add-method make-predicate 
  374.         (make-instance 
  375.          method 
  376.          'signature (list class)
  377.          'function 
  378.          (lambda (h1 h2 x)
  379.            (let ((gf (make-instance generic-function
  380.                     'name (make-symbol (format nil "~a-p" (class-name x)))
  381.                     'lambda-list '(obj)
  382.                     'method-class method)))
  383.          (add-method gf 
  384.                  (make-instance method 
  385.                         'signature (list object)
  386.                         'function (lambda (x y ob)
  387.                             nil)))
  388.          (add-method gf 
  389.                  (make-instance method 
  390.                         'signature (list x)
  391.                         'function (lambda (x y ob)
  392.                             t)))
  393.          gf))))
  394.  
  395. (export make-predicate)
  396.      
  397. )
  398.